Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/guile-ii.src/guile-ii/guile-src/slib/stdio.scm

Text File | 1994-06-06 | 4.4 KB | 150 lines

;;;; "stdio.scm" Implementation of <stdio.h> functions for Scheme
;;; Copyright (C) 1991-1993 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;;; Floating point is not handled yet.  It should not be hard to do.

(define (stdio:iprintf out format . args)
  (let loop ((pos 0) (args args))
    (if (< pos (string-length format))
    (case (string-ref format pos)
      ((#\\ )
       (set! pos (+ pos 1))
       (case (string-ref format pos)
         ((#\n #\N) (out #\newline))
         ((#\t #\T) (out slib:tab))
         ((#\r #\R) (out #\return))
         ((#\f #\F) (out slib:form-feed))
         (else (out (string-ref format pos))))
       (loop (+ pos 1) args))
      ((#\%)
       (set! pos (+ pos 1))
       (letrec ((left-adjust #f)
            (pad-char
             (if (char=? #\0 (string-ref format pos)) #\0 #\ ))
            (width 0)
            (prec #f)
            (pad
             (lambda (s)
               (cond ((<= width (string-length s)) s)
                 (left-adjust
                  (string-append
                   s
                   (make-string (- width (string-length s))
                        #\ )))
                 (else
                  (string-append
                   (make-string (- width (string-length s))
                        pad-char)
                   s))))))
         (let ilp ((pos pos))
           (case (string-ref format pos)
         ((#\d #\D #\u #\U)
          (out (pad (cond ((symbol? (car args))
                   (symbol->string (car args)))
                  ((number? (car args))
                   (number->string (car args)))
                  ((not (car args)) "0")
                  (else "1"))))
          (loop (+ pos 1) (cdr args)))
         ((#\c #\C)
          (out (pad (string (car args))))
          (loop (+ pos 1) (cdr args)))
         ((#\o #\O)
          (out (pad (number->string (car args) 8)))
          (loop (+ pos 1) (cdr args)))
         ((#\x #\X)
          (out (pad (number->string (car args) 16)))
          (loop (+ pos 1) (cdr args)))
         ((#\l #\L) (ilp (+ pos 1)))
         ((#\-) (set! left-adjust #t)
            (ilp (+ pos 1)))
         ((#\.)
          (set! prec 0)
          (set! pos (+ 1 pos))
          (let iilp ()
            (case (string-ref format pos)
              ((#\*) (set! prec (car args))
                 (set! args (cdr args))
                 (ilp (+ pos 1)))
              ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
               (set! prec
                 (+ (* prec 10)
                (- (char->integer (string-ref format pos))
                   (char->integer #\0))))
               (set! pos (+ 1 pos))
               (iilp))
              (else (ilp pos)))))
         ((#\%) (out #\%)
            (loop (+ pos 1) args))
         ((#\s #\S)
          (if (or (not prec)
              (>= prec (string-length (car args))))
              (out (pad (car args)))
              (out (pad (substring (car args) 0 prec))))
          (loop (+ pos 1) (cdr args)))
         ((#\*) (set! width (car args))
            (set! args (cdr args))
            (ilp (+ pos 1)))
         ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
          (set! width (+ (* width 10)
                 (- (char->integer (string-ref format pos))
                    (char->integer #\0))))
          (ilp (+ pos 1)))
         (else (out #\%)
               (out (string-ref format pos))
               (loop (+ pos 1) args))))))
      (else (out (string-ref format pos))
        (loop (+ pos 1) args))))))

(define (stdio:printf format . args)
  (apply stdio:iprintf display format args))

(define (stdio:fprintf port format . args)
  (if (equal? port (current-output-port))
      (apply stdio:iprintf display format args)
      (apply stdio:iprintf (lambda (x) (display x port)) format args)))

(define (stdio:sprintf s format . args)
  (let ((p 0) (end (string-length s)))
    (apply stdio:iprintf
       (lambda (x)
         (cond ((string? x)
            (do ((i 0 (+ i 1)))
            ((>= i (min (string-length x) end)))
              (string-set! s p (string-ref x i))
              (set! p (+ p 1))))
           ((>= p end))
           ((char? x)
            (string-set! s p x)
            (set! p (+ p 1)))
           (else
            (string-set! s p #\?)
            (set! p (+ p 1)))))
       format
       args)
    p))

(define printf stdio:printf)
(define fprintf stdio:fprintf)
(define sprintf stdio:sprintf)

(define stdin (current-input-port))
(define stdout (current-output-port))
(define stderr (current-error-port))